Shareware Grab Bag/Shareware Grab Bag.iso/050/plist.pqs/PLIST.PAS

Pascal/Delphi Source File | 1984-10-19 | 19.9 KB | 469 lines

program PLIST;
(*
  Written by: Rick Schaeffer
              E. 13611 26th Av.
              Spokane, Wa.  99216

  modifications (7/8/84  by Len Whitten, CIS: [73545,1006])
     1) added error handling if file not found
     2) added default extension of .PAS to main & include files
     3) added "WhenCreated" procedure to extract file
        creation date & time from TURBO FIB
     4) added demarcation of where include file ends
     5) added upper char. conversion to include file
     6) increased left margin to 5 spaces (80 char. line just fits @ 10cpi)
     7) added listing control: {.L-} turns it off, {.L+} turns it back on,
        must be in column 1

  further modifications (7/12/84 by Rick Schaeffer)
     1) cleaned up the command line parsing routines and put them in
        separate procedures.  Now permits any number of command line
        arguments, each argument separated with at least one space.
     2) added support for an optional second command line parameter
        which specifies whether include files will be listed or not.
        The command is invoked by placing "/i" on the command line
        at least one space after the file name to be listed.  For
        instance, to list MYPROG.PAS as well as any "included" files,
        the command line would be: PLIST MYPROG /I

   further modification (8/28/84) by Jay Kadashaw)
      1) Restored filedate and filetime after listing an included
         file.
      2) Added comment counter and begin/end counter.
      3) Output can be routed to either the printer or console.
      4) After listing first file the user is prompted for next
         file if any.
*)

(* Supported pseudo operations:
    1) Listing control: {.L-} turns it off, {.L+} turns it back on,
       must be in column 1
    2. Page ejection: {.PAGE}, must be in column 1.
    *)

 { When program is first run will check for a file
   name passed by DOS, and will try to open that file.  If no name is
   passed, will ask operator for a file name to open.  Proc will tell
   operator if file doesn't exist and will allow multiple retrys.

   Included files will be expanded only if the program is invoked as
   follows:
     pretty filename /i
   The default is not to expand included files.

   On 2nd and later executions, proc will not check for DOS passed file
   name.  In all cases, proc will assume a file type of .PAS if file
   type is not specified.
   PROGRAM EXIT from this proc when a null string is encountered in
   response to a file name request. }

const monthmask = $000F;
  daymask = $001F;
  minutemask = $003F;
  secondmask = $001F;
  First   : boolean = true;    {true when prog is run}

{ to customize code for your printer - adjust the next item }

  maxline = 58;

  cr = #13;
  lf = #10;
  ff = #12;

type
   two_letters = string[2];
   dtstr = string[8];
   fnmtype = string[14];
   instring = string[135];
   regpack = record
      ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
   end;

Var
  Buff1     : instring;          {input line buffer}
  listfil   : text;              {FIB for LST: or CON: output}
  infile    : text;              {FIB for input file}
  fnam      : fnmtype;           {in file name}
  bcount    : integer;           {begin/end counter}
  kcount    : integer;           {comment counter}
  linect    : integer;           {output file line counter}
  pageno    : integer;
  offset    : integer;
  print     : boolean;           (* {.L-} don't print *)
                                 (* {.L+} print       *)
  print_head : boolean;
  c         : char;
  month, day, year,
  hour, minute, second : two_letters;
  sysdate, systime,
  filedate, filetime : dtstr;
  expand_includes    : boolean;
  holdarg            : instring;
  allregs : regpack;
{.page}
procedure getchar(var char_value : char);
   begin
     allregs.ax := $0000;
     intr($16, allregs);
     char_value := chr(ord(lo(allregs.ax)));
   end; {getchar}

procedure fill_blanks (var line: dtstr);
  var
    i : integer;
begin
  for i:= 1 to 8 do if line[i] = ' ' then line[i]:= '0';
end;  {fill_blanks}

procedure getdate(var date : dtstr);

begin
   allregs.ax := $2A * 256;
   MsDos(allregs);
   str((allregs.dx div 256):2,month);
   str((allregs.dx mod 256):2,day);
   str((allregs.cx - 1900):2,year);
   date := month + '/' + day + '/' + year;
   fill_blanks (date);
end;  {getdate}

procedure gettime(var time : dtstr);

begin
   allregs.ax := $2C * 256;
   MsDos(allregs);
   str((allregs.cx div 256):2,hour);
   str((allregs.cx mod 256):2,minute);
   str((allregs.dx div 256):2,second);
   time := hour + ':' + minute + ':' + second;
   fill_blanks (time);
end;  {gettime}

procedure WhenCreated (var date, time: dtstr; var infile: text);

var fulltime,fulldate: integer;

begin

{fulldate gets the area of the FIB which corresponds to bytes 20-21
 of the FCB. Format is: bits 0 - 4: day of month
                             5 - 8: month of year
                             9 -15: year - 1980                     }

    fulldate:= memw [seg(infile):ofs(infile)+31];
    str(((fulldate shr 9) + 80):2,year);
    str(((fulldate shr 5) and monthmask):2,month);
    str((fulldate and daymask):2,day);
    date:= month + '/' + day + '/' + year;
    fill_blanks(date);

{fulltime gets the area of the FIB which corresponds to bytes 22-23
 of the FCB. Format is: bits 0 - 4: seconds/2
                             5 -10: minutes
                             11-15: hours                          }

    fulltime:= memw [seg(infile):ofs(infile)+33];
    str((fulltime shr 11):2,hour);
    str(((fulltime shr 5) and minutemask):2,minute);
    str(((fulltime and secondmask) * 2):2,second);
    time:= hour + ':' + minute + ':' + second;
    fill_blanks (time);
end;  {WhenCreated}

procedure print_heading(filename : fnmtype);

var offset_inc: integer;

begin
   if print then
     begin
       pageno := pageno + 1;
       if pageno > 1 then write(listfil, ff);  {top of form}
       writeln(listfil);
       write(listfil,'     TURBO Pascal Program Lister');
       writeln(listfil,' ':8,'Printed: ',sysdate,'  ',
               systime,'   Page ',pageno:4);
       if filename <> fnam then begin
          offset_inc:= 14 - length (filename);
          write(listfil,'     Include File: ',filename,' ':offset_inc,
             'Created: ',filedate,'  ',filetime);
       end
       else write(listfil,'     Main File: ',fnam,' ':offset,
             'Created: ',filedate,'  ',filetime);
       writeln(listfil); writeln(listfil);
       writeln(listfil, ' C  B');
       writeln(listfil);
       linect := 6;
     end; {check for print}
end;  {print_heading}

procedure printline(iptline : instring; filename : fnmtype);
begin
   if print then
     begin
       if linect < 56 then
         begin
          writeln(listfil,'     ',iptline);
          linect := linect + 1;
         end
          else
           begin
             print_heading(filename);
           end;
     end; {check for print}
end;  {printline}
{.page}
function chkinc(var iptline : instring; var incflname : fnmtype) : boolean;
var
   done : boolean;
   i, j : integer;
begin
   i := 4; j := 1; incflname := '';
   if copy(iptline, 1, 3) = '{$I' then begin
      i := 4; j := 1; incflname := '';
      while (iptline[i] = ' ') and (i <= length(iptline)) do i := i + 1;
      done := false;
      while not done do begin
         if i <= length(iptline) then begin
            if not (iptline[i] in [' ','}','+','-']) then begin
               incflname[j] := iptline[i];
               i := i + 1; j := j + 1;
            end else done := true;
         end else done := true;
         if j > 14 then done := true;
      end;
      incflname[0] := chr(j - 1);
   end;
   if incflname <> '' then chkinc := true else chkinc := false;
end;  {chkinc}

function parse_cmd(argno : integer) : instring;
var
   i,j : integer;
   wkstr : instring;
   done : boolean;
   cmdline : ^instring;
begin
   cmdline := ptr(CSEG,$0080);
   wkstr := '';
   done := false; i := 1; j := 0;
   if length(cmdline^) < i then done := true;
   repeat
      while ((cmdline^[i] = ' ') and (not done)) do begin
         i := i + 1;
         if i > length(cmdline^) then done := true;
      end;
      if not done then j := j + 1;
      while ((cmdline^[i] <> ' ') and (not done)) do begin
         wkstr := wkstr + cmdline^[i];
         i := i + 1;
         if i > length(cmdline^) then done := true;
      end;
      if (j <> argno) then wkstr := '';
   until (done or (j = argno));
   for i := 1 to length(wkstr) do
      wkstr[i] := upcase(wkstr[i]); {all arguments forced to upper case}
   parse_cmd := wkstr;
end;

 PROCEDURE GET_IN_FILE;     {GETS INPUT FILE NAME }
   var
    existing : boolean;
  begin
    repeat             {until file exists}
      holdarg := parse_cmd(1); {get command line argument # 1}
      if (length(holdarg) in [1..14]) and first then
        fnam := holdarg  {move possible file name to fnam}
      else
        begin
          writeln;
          write(' ENTER FILE NAME TO LIST or <cr> to EXIT  ');
          readln(fnam);
        end;

     if fnam = '' then HALT;         {***** EXIT *****}
     if pos('.',fnam) = 0 then       {file type given?}
       fnam := concat(fnam,'.PAS');  {file default to .PAS type}

     {get optional command line argument # 2}
     if (length(holdarg) in [1..14]) and first then
       begin
         holdarg := parse_cmd(2);
         if holdarg = '/I' then expand_includes := true
            else expand_includes := false;
       end;

     first := false;                 {get passed file name only once}
     assign( infile, fnam);
       {$I-}
     reset( infile );                {check for existence of file}
       {$I+}
     existing := (ioresult = 0);     {true if file found}
     if not existing then
       begin
        writeln;
        writeln(' FILE DOESN''T EXIST'); {tell operator the sad news}
       end;
    until existing;                     {until file exists}
 end; {GET_IN_FILE}

{ GET_OUT_FILE procedure asks operator to select output to console
  device or list device, and then assigns and resets a file control
  block to the appropriate device.  'C' or 'P' is only correct
  response, and multiple retrys are allowed. }

Procedure Get_Out_File;
  var
    c : char;
  begin
    repeat    {until good selection}
      writeln; write(' OUTPUT LISTING TO (C)ONSOLE OR (P)RINTER ?  ');
      getchar(c);
      c := upcase(c); write(c);
   until c in ['C', 'P'];

   writeln;
   if c = 'C' then
      assign (listfil, 'CON:')
   else
      assign (listfil, 'LST:');

   reset(listfil);
 end;  {GET_OUT_FILE}

Procedure ListIt(filename : fnmtype); forward;
{.page}
{ SCAN_LINE procedure scans one line of Turbo Pascal source code
  looking for BEGIN/END pairs, CASE/END pairs, LITERAL fields
  and COMMENT fields.  BCOUNT is begin/end and case/end counter.
  KCOUNT is comment counter.  Begin/case/ends are only valid
  outside of comment fields and literal constant fields (KCOUNT = 0
  and NOT LITERAL).
  Some of the code in the SCAN_LINE procedure appears at first glance
  to be repitive and/or redundant, but was added to speed up the
  process of scanning each line of source code.}

Procedure SCAN_LINE;
  var
    literal : boolean;          { true if in literal field}
    tmp     : string[7];        { tmp work area }
    i       : integer;          {loop variable index}
    buff2   : instring;         {working line buffer}
    incflname : fnmtype;        {in file name}
    filedate_save : dtstr;
    filetime_save : dtstr;
  begin
    literal := false;

    buff2[0] := buff1[0];  {copy input buffer to working buffer}
    for i := 1 to length(buff1) do
     buff2[i] := upcase(buff1[i]);  {and translate to upper case}

    if chkinc(buff2, incflname) and expand_includes then
       begin
       for i := 1 to length(incflname) do
           incflname[i] := upcase(incflname[i]);
          if pos('.',incflname) = 0 then incflname := incflname + '.PAS';
          printline('*************************************',incflname);
          printline('    Including "'+incflname+'"', incflname);
          printline('*************************************',incflname);
          filedate_save := filedate;  {save filedate & filetime for}
          filetime_save := filetime;  {main file                   }
          listit(incflname);
          filedate := filedate_save;  {restore}
          filetime := filetime_save;
          printline('*************************************',incflname);
          printline('    End of    "'+incflname+'"', incflname);
          printline('*************************************',incflname);
         end;  {include file check}

    if copy(buff2,1,5) = '{.L-}' then print := false;
    if copy(buff2,1,5) = '{.L+}' then print := true;

    if copy(buff2,1,7) = '{.PAGE}' then print_head := true;

    buff2 := concat('  ', buff2, '      ');  {add on some working space}
    for i := 1 to length(buff2) - 6 do
      begin
        tmp := copy(buff2, i, 7);
        if not literal then   {possible to find comment delim}
          begin
           {determine if comment area delim}
           if tmp[1] in ['{', '}', '(', '*'] then
             begin
               if (tmp[1] = '{') or (copy(tmp,1,2)='(*') then
                 kcount := succ(kcount);  {count comment opens}
               if (tmp[1] = '}') or (copy(tmp,1,2)='*)') then
                 kcount := pred(kcount);  {un-count comment closes}
             end;
          end;

         if kcount = 0 then  {we aren't in a comment area}
           begin
            if tmp[1] = chr(39) then
              literal := not literal;   {toggle literal flag}

           if not literal and (tmp[2] in ['B','C','E']) then
             begin
               if (tmp = ' BEGIN ') or (copy(tmp,1,6) = ' CASE ') then
                begin
                 bcount := succ(bcount);  {count BEGIN}
                 i := i + 5;              {skip rest of begin}
                end;
               if (copy(tmp,1,4) = ' END') and
                  (tmp[5] in ['.', ' ', ';']) and
                   (bcount > 0) then
                begin
                 bcount := pred(bcount);   {un-count for END}
                 i := i + 4;
                end;
              end;  {if not literal}
           end;  { if kcount = 0 }
        end;  { for i := }
    end;  {SCAN_LINE}
{.page}
Procedure ListIt;
  var
    infile : text;
  begin
     assign(infile, filename);
   {$I-} reset(infile) {$I+} ;
   if IOresult <> 0 then begin
      writeln ('File ',filename,' not found.');
      halt;
   end;
     WhenCreated (filedate,filetime,infile);
         print_heading(filename);
         while not eof(infile) do
           begin
            readln(infile, buff1);
            scan_line;
            if print_head then
                print_heading(filename);
            if print and (not print_head) then
              begin
                writeln(listfil,kcount : 2, bcount : 3, '  ', buff1);
                linect := succ(linect);
                if linect > maxline then
                  begin
                    print_heading(filename);
                  end;
              end;
            print_head := false;
         end;     {while not eof}
  end; {ListIt}

{.page}
  begin {main procedure}
     getdate(sysdate);
     gettime(systime);
     expand_includes := false;       {default settings}
     print := true;

   repeat {forever}
     ClrScr;
     GotoXY(2, 2);
     writeln('TURBO Pascal :tinnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn ikkkkkkkkkkkkkmititinhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhryontmitifnnimeimntntntndasiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiintntnmmnt '
 as'
 mkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkknn                                iyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyr tlshrl mlgtititifniicetmntntnaaeddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd tititinhtmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm ummmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmftethn                                iyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyytititisis)'rbnnnn;i't:)tmitinnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn 'astititinhtmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm uas'
 mkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkknn                                iyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy:tlfhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhntntntntntnonbnltrsttttttttttrotkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkntntnmmnaasummmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm umkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkknamy_________________________________________________________________________________________________mititiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiic
rtlreimntno
te grtntntntnaast_ititinhtmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm ummmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmumkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkknn iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiidtei tls'S ggggggggggggggr )ta bicetmntntnarsgastititinhtmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm ummmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmftethn                                ikkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk tititificmlragseten
l 'C ntmititiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiitkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkntntnmmnt '
 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmumkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkknn iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiidiei tltanrnldthtntntntntntntntntnpdddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd t_ititinhtrsiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiidh umkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkknaroikkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkktititisin
ngh'ig6h;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;angtitiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnntntnmmnt s u